home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
doordr40.zip
/
NEWS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-03-17
|
21KB
|
716 lines
{$M 48000,0,64000}
{ EXAMPLE DOOR: ONLINE NEWS }
{ By Scott Baker }
{ }
{ This program was written for some friends who were using various }
{ online news magazines for their bbs system. (i.e. USA TODAY, INFOMAT, }
{ NEWSBYTES, etc). It demonstrates the usage of the ANSI-MENU routines }
{ as well as some general door-writing ideas. }
{ Since the program was written in kind of a hurry, the routines }
{ may have a few small programming flaws, but all-in-all, it works. If }
{ you use ANY of the code in this sample program, then please credit me }
{ in your program. }
uses Dos, ddScott, Crt, DoorDriv, AnsiMenu;
const
menu1: menutype =
(header: 'Online News and Magazine System';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 5;
options: ('A','B','C','D','Q','','','','','','','','','','',
'','','','','');
desc: ('USA Today Decisionline', 'InfoMat magazine',
'NewsBytes magazine', 'BoxOffice magazine',
'Quit to bbs', '',
'', '',
'','','','','','','','','','','',''));
menu2: menutype =
(header: 'USA-Today Decisionline';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 13;
options: ('A','B','C','D','E','F','G','H','I','J','K','L','M','',
'','','','','','');
desc: ('Advertising', 'Banking',
'Bonus', 'Energy',
'Health', 'Insurance',
'International', 'Issues',
'Legal', '- Next Page -',
'Headline Scan', 'KeyWord Scan',
'Quit to Main',
'','','','','','',''));
menu22: menutype =
(header: 'USA-Today Decisionline';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 13;
options: ('A','B','C','D','E','F','G','H','I','J','K','L','M','',
'','','','','','');
desc: ('News',
'Personal', 'Realtors',
'Sports', 'Technology',
'TeleCom', 'Travel',
'Trends', 'Weather',
'- Prev Page -', 'Headline Scan',
'KeyWord Search', 'Quit to main',
'','','','','','',''));
menu3: menutype =
(header: 'BoxOffice magazine';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 11;
options: ('A','B','C','D','E','F','G','H','I','J','K','','','','',
'','','','','');
desc: ('Top 10 video rentals', 'Top 10 Grossing films',
'Coming festivals and events', 'Hollywood news ',
'Sneak previews ', 'Boxoffice Trailers',
'Special Features/interviews', 'Boxoffice Movie Reviews',
'Boxoffice Hollywood reports', 'New Video Releases',
'Quit to main','','','','','','','','',''));
menu4: menutype =
(header: 'Info-Mat magazine';
footer: 'Please type a command letter: ';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 13;
options: ('A','B','C','D','E','F','G','H','I','J','K','L','M','','',
'','','','','');
desc: ('BBS Index', 'Computer Industry News',
'Software news part 1', 'Software news part 2',
'HardWare news', 'General computer news',
'Telecom news part 1', 'Telecom news part 2',
'Networker''s Journal', 'I didn''t know......',
'Shareware/PD software', 'The editor Speaks',
'Quit to bbs',
'','','','','','',''));
menu5: menutype =
(header: 'News Bytes Magazine';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 13;
options: ('A','B','C','D','E','F','G','H','I','J','K','L','M','','',
'','','','','');
desc: ('Executive Summary', 'The IBM Report',
'The Apple Report', 'The UNIX Report',
'General News', 'Trends and Technology',
'Business News', 'Government News',
'Stock Report', 'Telecommunications',
'WYSIWYG Column', 'Boston Computer Ex. Prices',
'Quit to bbs',
'','','','','','',''));
menu6: menutype =
(header: 'Box Office Magazine reviews (pg1)';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 13;
options: ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
'P','Q','R','S','T');
desc: ('','','','','','','','','','','','','','','','','','','',''));
menu7: menutype =
(header: 'Box Office Magazine reviews (pg2)';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 13;
options: ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
'P','Q','R','S','T');
desc: ('','','','','','','','','','','','','','','','','','','',''));
var
USATodayDir: string;
InfomatDir: string;
NewsBytesDir: string;
BoxOfficeDir: string;
FidoNewsFile: string;
RbbsBitsFile: string;
BBSListFile: string;
Headercolor, footercolor, optioncolor, desccolor, arrowcolor, bracketcolor: byte;
CallerFileName: string;
CallerFile: text;
procedure olddisplayfile(s: string);
begin;
displayfile(s);
end;
procedure displayfile(s: string);
begin;
olddisplayfile(s);
swriteln('');
set_foreground(green);
swrite('PRESS RETURN:');
set_foreground(default_fore);
sread_char(ch);
end;
procedure getdirs;
var
f: text;
begin;
if not exist('NEWS.DIR') then begin;
swriteln('News.dir missing!');
halt;
end;
assign(f,'News.dir');
reset(f);
readln(f,usatodaydir);
readln(f,infomatdir);
readln(f,newsbytesdir);
readln(f,boxofficedir);
readln(f,FidoNewsFile);
readln(f,RbbsBitsFile);
readln(f,BBSListFile);
readln(f,headercolor);
readln(f,footercolor);
readln(f,desccolor);
readln(f,optioncolor);
readln(f,arrowcolor);
readln(f,bracketcolor);
readln(f,callerfilename);
close(f);
if usatodaydir[1]=';' then usatodaydir:='';
if infomatdir[1]=';' then infomatdir:='';
if newsbytesdir[1]=';' then newsbytesdir:='';
if boxofficedir[1]=';' then boxofficedir:='';
if fidonewsfile[1]=';' then fidonewsfile:='';
if rbbsbitsfile[1]=';' then rbbsbitsfile:='';
if bbslistfile[1]=';' then bbslistfile:='';
if callerfilename[1]=';' then callerfilename:='';
end;
function filedate(s: string): string;
var
f: file;
s2: string;
time: longint;
dt: datetime;
begin;
s2:='??-??-??';
filedate:=s2;
if not exist(s) then exit;
assign(f,s);
reset(f);
getftime(f,time);
unpacktime(time,dt);
s2:=va(dt.month)+'-'+va(dt.day)+'-'+va(dt.year-1900);
filedate:=s2;
end;
procedure OpenCaller;
var
s: string;
a: integer;
begin;
s:='';
for a:=1 to length(CallerFileName) do if callerfilename[a]='%' then s:=s+va(node_num) else s:=s+callerfilename[a];
if not exist(s) then begin;
callerfilename:='';
exit;
end;
assign(callerfile,s);
append(callerfile);
end;
procedure CloseCaller;
begin;
if callerfilename<>'' then close(callerfile);
end;
procedure AddCaller(s: string);
begin;
if callerfilename<>'' then writeln(callerfile,s);
end;
procedure DisplayUSA(s: string);
begin;
AddCaller(' read '+s);
displayfile(USATodayDir+'\'+s);
end;
procedure DisplayBOX(s: string);
begin;
AddCaller(' read '+s);
displayfile(BoxOfficeDir+'\'+s);
end;
procedure DisplayIMAN(s: string);
begin;
AddCaller(' read '+s);
displayfile(infomatdir+'\'+s);
end;
procedure DisplayByte(s: string);
begin;
AddCaller(' read '+s);
displayfile(NewsBytesdir+'\'+s);
end;
function blankline(s: string): boolean;
begin;
blankline:=false;
if s='' then begin;
blankline:=true;
exit;
end;
while s[length(s)]=' ' do delete(s,length(s),1);
if s='' then begin;
blankline:=true;
exit;
end;
end;
procedure keyword_search(fn: string; word: string; var cont: boolean);
var
f: text;
tbuff: array[1..20] of string[85];
trigger: boolean;
bufcnt: byte;
s: string;
a: integer;
nonstop: boolean;
begin;
assign(f,fn);
reset(f);
nonstop:=false;
cont:=true;
trigger:=false;
bufcnt:=0;
while (not eof(f)) and (cont) do begin;
readln(f,s);
if not blankline(s) then begin;
if bufcnt<20 then bufcnt:=bufcnt+1;
tbuff[bufcnt]:=s;
if pos(stu(word),stu(s))<>0 then trigger:=true;
end else begin;
if trigger then begin;
for a:=1 to bufcnt do swriteln(tbuff[a]);
swriteln('');
if (not nonstop) then begin;
set_foreground(green);
swrite('[C]ontinue,[S]top,[N]onstop ? ');
set_foreground(default_fore);
sread_char(ch);
while wherex>1 do swrite(#8+' '+#8);
ch:=upcase(ch);
if ch='S' then cont:=false;
if ch='N' then nonstop:=true;
end;
end;
trigger:=false;
bufcnt:=0;
end;
end;
close(f);
end;
procedure KeywordUSA;
const
usafilenames: array[1..18] of string =
('Advertis','banking','bonus','energy','health','insure',
'interntl','issues','legal','news','personal','realtors',
'sports','technol','telecom','travel','trends','weather');
var
word: string;
cont: boolean;
a: integer;
begin;
set_foreground(lightcyan);
swrite('Enter Keyword for search: ');
set_foreground(white);
sread(word);
set_foreground(default_fore);
cont:=true;
a:=1;
while (a<19) and (cont) do begin;
keyword_search(usatodaydir+'\'+usafilenames[a]+'.usa',word,cont);
a:=a+1;
end;
end;
procedure USAToday2(var ch: char);
begin;
ch:=' ';
repeat;
menu22.header:='USA-Today Decisionline '+filedate(usatodaydir+'\'+'advertis.usa');
ch:=Getansimenu(menu22);
sclrscr;
case ch of
'A': displayUSA('News.usa');
'B': displayUSA('Personal.usa');
'C': displayUSA('Realtors.usa');
'D': displayUSA('Sports.usa');
'E': displayUSA('Technol.usa');
'F': displayUSA('Telecom.usa');
'G': displayUSA('Travel.usa');
'H': displayUSA('Trends.usa');
'I': displayUSA('Weather.usa');
'K': displayUSA('Headline.usa');
'L': KeyWordUSA;
end;
until (ch='M') or (ch='J');
end;
procedure USAToday;
var
ch: char;
begin;
AddCaller(' Entered USA-Today Section');
repeat;
menu2.header:='USA-Today Decisionline '+filedate(usatodaydir+'\'+'advertis.usa');
ch:=Getansimenu(menu2);
sclrscr;
case ch of
'A': displayUSA('Advertis.usa');
'B': displayUSA('Banking.usa');
'C': displayUSA('Bonus.usa');
'D': displayUSA('Energy.usa');
'E': displayUSA('Health.usa');
'F': displayUSA('Insure.usa');
'G': displayUSA('Interntl.usa');
'H': displayUSA('Issues.usa');
'I': displayUSA('Legal.usa');
'J': USAToday2(ch);
'K': displayUSA('Headline.usa');
'L': KeyWordUSA;
end;
until ch='M';
end;
procedure InfoMat;
var
ch: char;
begin;
AddCaller(' Entered InfoMat Magazine Section');
repeat;
ch:=Getansimenu(menu4);
sclrscr;
case ch of
'A': displayIMAN('IMAN1.TXT');
'B': displayIMAN('IMAN2.TXT');
'C': displayIMAN('IMAN3.TXT');
'D': displayIMAN('IMAN4.TXT');
'E': displayIMAN('IMAN5.TXT');
'F': displayIMAN('IMAN6.TXT');
'G': displayIMAN('IMAN7.TXT');
'H': displayIMAN('IMAN8.TXT');
'I': displayIMAN('IMAN9.TXT');
'J': displayIMAN('IMAN10.TXT');
'K': displayIMAN('IMAN11.TXT');
'L': displayIMAN('IMAN12.TXT');
end;
until ch='M';
end;
procedure NewsBytes;
var
ch: char;
begin;
AddCaller(' Entered NewsBytes Section');
repeat;
ch:=Getansimenu(menu5);
sclrscr;
case ch of
'A': displayBYTE('Exec.nsb');
'B': displayBYTE('IBM.nsb');
'C': displayBYTE('Apple.nsb');
'D': displayBYTE('unix.nsb');
'E': displayBYTE('general.nsb');
'F': displayBYTE('trends.nsb');
'G': displayBYTE('business.nsb');
'H': displayBYTE('governmnt.nsb');
'I': displayBYTE('stocks.nsb');
'J': displayBYTE('telecom.nsb');
'K': displayBYTE('wysiwyg.nsb');
'L': displayBYTE('bostcomp.nsb');
end;
until ch='M';
end;
function KillTHE(s: string): string;
begin;
if pos('THE ',stu(s))=1 then delete(s,1,4);
if pos('A ',stu(s))=1 then delete(s,1,2);
KillTHE:=s;
end;
procedure boxreview;
type
boxrec = record
fname: string[12];
desc: string[35];
letter: char;
menunum: byte;
end;
const
letters: string= ('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
type
reviewtype= array[1..512] of boxrec;
reviewptr= ^reviewtype;
var
a,b,c: integer;
ch: char;
fname: string;
sr: searchrec;
reviews1,reviews2: reviewptr;
s: string;
num,n,numentries,menunum: word;
numsort,lowrevnum: word;
nummenus, highnum: word;
lowrevdesc: string;
f: text;
menu: array[1..20] of menutype;
begin;
new(reviews1);
new(reviews2);
for a:=1 to 512 do begin;
reviews1^[a].desc:='';
reviews1^[a].fname:='';
reviews1^[a].letter:=' ';
end;
findfirst(boxofficedir+'\br*.*',anyfile,sr);
numentries:=0;
while doserror=0 do begin;
numentries:=numentries+1;
s:='';
for a:=pos('R',sr.name)+1 to pos('.',sr.name)-1 do s:=s+sr.name[a];
val(s,num,b);
reviews1^[num].fname:=sr.name;
assign(f,boxofficedir+'\'+sr.name);
reset(f);
readln(f,reviews1^[num].desc);
close(f);
findnext(sr);
end;
numsort:=0;
repeat;
lowrevnum:=0;
lowrevdesc:='ZZZZZZZZ';
for a:=1 to 512 do if reviews1^[a].desc<>'' then
if killTHE(reviews1^[a].desc)<killTHE(lowrevdesc) then begin;
lowrevnum:=a;
lowrevdesc:=reviews1^[a].desc;
end;
if lowrevnum<>0 then begin;
numsort:=numsort+1;
reviews2^[numsort]:=reviews1^[lowrevnum];
reviews1^[lowrevnum].desc:='';
end;
until lowrevnum=0;
nummenus:=(numsort div 10)+1;
for a:=1 to nummenus do begin;
menu[a]:=menu6;
highnum:=((a-1)*10)+10;
if highnum>numsort then highnum:=numsort;
c:=0;
for b:=((a-1)*10)+1 to highnum do begin;
c:=c+1;
menu[a].options[c]:=letters[c];
menu[a].desc[c]:=reviews2^[b].desc;
reviews2^[b].letter:=letters[c];
reviews2^[b].menunum:=a;
end;
c:=c+1;
if a<nummenus then begin;
menu[a].options[c]:='N';
menu[a].desc[c]:='Next Menu';
c:=c+1;
end;
if a>1 then begin;
menu[a].options[c]:='P';
menu[a].desc[c]:='Previous Menu';
c:=c+1;
end;
menu[a].options[c]:='Q';
menu[a].desc[c]:='Quit to BoxOffice Menu';
menu[a].numoptions:=c;
end;
menunum:=1;
repeat;
ch:=getansimenu(menu[menunum]);
sclrscr;
ch:=upcase(ch);
fname:='';
for a:=1 to numsort do if (ch=reviews2^[a].letter) and (reviews2^[a].menunum=menunum) then fname:=reviews2^[a].fname;
if fname<>'' then displayBOX(fname);
if ch='N' then menunum:=menunum+1;
if ch='P' then menunum:=menunum-1;
until ch='Q';
dispose(reviews1);
dispose(reviews2);
end;
procedure Boxoffice;
var
ch: char;
begin;
AddCaller(' Entered BoxOffice Magazine');
repeat;
ch:=getansimenu(menu3);
sclrscr;
case ch of
'A': displayBOX('topvid.txt');
'B': displayBOX('botop10.txt');
'C': displayBOX('fest.txt');
'D': displayBOX('hwd.txt');
'E': displayBOX('sneak.txt');
'F': displayBOX('trail.txt');
'G': displayBOX('bfeal.txt');
'H': boxreview;
'I': displayBOX('hrl.txt');
'J': displayBOX('ovnew.txt');
end;
until ch='K';
end;
procedure SetMenuColor(var menu: menutype);
begin;
menu.headercolor:=headercolor;
menu.footercolor:=footercolor;
menu.optioncolor:=optioncolor;
menu.desccolor:=desccolor;
menu.arrowcolor:=arrowcolor;
menu.bracketcolor:=bracketcolor;
end;
procedure mainmenu;
const
letters: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var
ch: char;
select: byte;
selections: array[1..100] of byte;
begin;
menu1.numoptions:=0;
if USATodaydir<>'' then begin;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:=letters[menu1.numoptions];
menu1.desc[menu1.numoptions]:='USA Today Decisionline';
selections[ord(letters[menu1.numoptions])]:=1;
end;
if InfoMatDir<>'' then begin;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:=letters[menu1.numoptions];
menu1.desc[menu1.numoptions]:='InfoMat magazine';
selections[ord(letters[menu1.numoptions])]:=2;
end;
if NewsBytesDir<>'' then begin;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:=letters[menu1.numoptions];
menu1.desc[menu1.numoptions]:='NewsBytes magazine';
selections[ord(letters[menu1.numoptions])]:=3;
end;
if Boxofficedir<>'' then begin;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:=letters[menu1.numoptions];
menu1.desc[menu1.numoptions]:='BoxOffice Magazine';
selections[ord(letters[menu1.numoptions])]:=4;
end;
if FidonewsFile<>'' then begin;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:=letters[menu1.numoptions];
menu1.desc[menu1.numoptions]:='FidoNews Newsletter';
selections[ord(letters[menu1.numoptions])]:=5;
end;
if RbbsbitsFile<>'' then begin;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:=letters[menu1.numoptions];
menu1.desc[menu1.numoptions]:='Rbbsbits Newsletter';
selections[ord(letters[menu1.numoptions])]:=6;
end;
if BBSListFile<>'' then begin;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:=letters[menu1.numoptions];
menu1.desc[menu1.numoptions]:='Local BBS listing';
selections[ord(letters[menu1.numoptions])]:=7;
end;
menu1.numoptions:=menu1.numoptions+1;
menu1.options[menu1.numoptions]:='Q';
menu1.desc[menu1.numoptions]:='Quit to bbs';
selections[ord('Q')]:=8;
repeat;
ch:=Getansimenu(menu1);
sclrscr;
select:=selections[ord(ch)];
case select of
1: UsaToday;
2: infomat;
3: newsbytes;
4: BoxOffice;
5: displayfile(fidonewsfile);
6: displayfile(rbbsbitsfile);
7: displayfile(bbslistfile);
end;
until select=8;
end;
begin;
InitDoorDriver('NEWS.CTL');
progname:='Online News';
midscreeny:=12;
midscreenx:=40;
getdirs;
setmenucolor(menu1);
setmenucolor(menu2);
setmenucolor(menu22);
setmenucolor(menu3);
setmenucolor(menu4);
setmenucolor(menu5);
setmenucolor(menu6);
setmenucolor(menu7);
swriteln('ONLINE NEWS Version 2.00 by Scott M. Baker');
swriteln('');
delay(1000);
OpenCaller;
mainmenu;
CloseCaller;
end.